          
#|___________________________________________________________________ 
 | 
 | ViSta - The Visual Statistics System
 | Copyright (c) 1991-2000 by Forrest W. Young
 | For further information contact the author 
 |
 | This file contains constructor functions 
 | for various types of display windows, including
 |
 |     POST-IT 
 |     POST-IT-HELP 
 |     ONE-LINER 
 |     HELP (in lspsrc\help.lsp)
 |     HELP-WINDOW 
 |     PLOT-HELP-WINDOW
 |     VISTA-MESSAGE
 |     VISTA-WARNING-WINDOW 
 |     VISTA-ERROR-WINDOW
 |     COLOR-PATCH
 |___________________________________________________________________ 
 |# 


;
;PLEASE-WAIT, POST-IT, POST-IT-HELP, ONE-LINER (container-message)
;

(defun container-message (message &key (in *desktop-container*) (delay-time 2) 
                                  (show-time nil) (lines nil))
  (let ((start-time (/ (get-internal-real-time)
                       internal-time-units-per-second)))
    (send in :delayed-container-message message :lines lines
          :start-time start-time :delay-time delay-time :show-time show-time)))


(defmeth container-proto :delayed-container-message 
  (message &key (lines nil) (start-time start-time) (delay-time 2) (show-time nil))
  (let ((dw))
    (defmeth self :do-idle ()
      (let ((current-time (/ (get-internal-real-time)
                                internal-time-units-per-second))
            )
        (when (> (- current-time start-time) delay-time) 
              (send self :idle-on nil)
              (defmeth self :do-idle ())
              (setf dw (send self :container-message message 
                             :lines lines :show-time show-time)))))
    (send self :idle-on t)
    dw))

(defmeth container-proto :container-message 
  (message &key (in self) (show-time nil) (color 'white) 
           (shrink-wrap nil used-sw?) (fit nil used-f?) 
           (width 350) (pause 0) (title " ") (show t) 
           (center t) (click t) (lines nil) (location nil))
"Args: (message &key (in self) (show-time nil) (color 'white) 
                (fit t) (shrink-wrap t) (width 350) (pause 0) 
                (title nil) (show t) (center t)  
                (lines nil) (location nil))
Creates a window containing MESSAGE text."
  (when (not location)
        (setf location (floor (/ (- (send self :size) (list width 0)) 2)))) ;width 98
  (when (and used-sw? used-f?) 
        (error "cant used shrinkwrap and fit options at same time"))
  (let* ((tw 
          (cond 
            ((or (not lines) (not title))
             width)
            ((= lines 0)
             (floor (* .9 (send self :text-width title))))
            (t width)))
         (num-window-lines lines)
         (pop-out (not in))
         (top-most pop-out)
         (dw (make-new-display-window-proto2-instance 
              :in in :relocate nil
              :size (list tw 0) :location location ;width 48
              :title title :color color :show nil
              :pop-out pop-out :top-most top-most
              :free nil :local-menus t :menu t))   
         (start-time (/ (get-internal-real-time)
                        internal-time-units-per-second))
         (show-lines nil) (new-height) 
         (cont self))
    (send dw :add-slot 'start-time)
  
    (defmeth dw :start-time (&optional (real nil set))
      (if set (setf (slot-value 'start-time) real))
      (slot-value 'start-time))

    (send dw  :start-time (/ (get-internal-real-time)
                        internal-time-units-per-second))

    (send dw :add-slot 'num-window-lines)
  
    (defmeth dw :num-window-lines (&optional (real nil set))
      (if set (setf (slot-value 'num-window-lines) real))
      (slot-value 'num-window-lines))

    (unless num-window-lines (setf num-window-lines 6))
    (cond 
      ((= num-window-lines 0) 
       (send dw :has-v-scroll nil)
       (send dw :size tw -10)
       (apply #'send dw :location 
              (floor (/ (- *real-screen-size* 
                           (list (first (send dw :size)) 0)) 2))))
      (t
       (send dw :back-color color)
       (send dw :redraw)
       (send dw :paste-string message)
       (setf show-lines (if num-window-lines num-window-lines 
                            (if shrink-wrap 
                                (max 3 (1+ (send dw :nlines)))
                                7)))
       (setf new-height (* (send dw :line-height) show-lines))
       (send dw :size (first (send dw :size)) new-height)
       (when center
             (apply #'send dw :location 
                    (+ '(0 10) (floor (/ (- *real-screen-size* 
                                            (list (first (send dw :size)) new-height))
                                            2)))))
       (send dw :redraw)))

    (send dw :num-window-lines show-lines)

    (send dw :add-slot 'fit)
  
    (defmeth dw :fit (&optional (real nil set))
      (if set (setf (slot-value 'fit) real))
      (slot-value 'fit))

    (send dw :fit shrink-wrap)

    (defmeth dw :close ()
      (send dw :idle-on nil)
      (send dw :true-location (send dw :location))
      (send dw :location 2000 2000))

    (defmeth dw :hide-window ()
      (send dw :idle-on nil)
      (send dw :true-location (send dw :location))
      (send dw :location 2000 2000))

    (defmeth dw :show-window (&key (relocate t))
      (if relocate
          (apply #'send dw :location (send dw :true-location))
          (call-next-method :relocate relocate)))

   ; (defmeth dw :do-click (x y m1 m2)
   ;   (send dw :close))

    (defmeth dw :do-idle ()
      (let ((start-time (send dw :start-time))
            (current-time (/ (get-internal-real-time)
                             internal-time-units-per-second)))
        (when (and show-time
                   (> (- current-time start-time) show-time)) 
              (send dw :close)))) ; remove

    (defmeth dw :reset-time (time)
      (setf show-time time)
      (send self :idle-on t))

    (defmeth dw :click (logical)
      (send dw :idle-on logical))

    
    (defmeth dw :new-size ()
      (let* ((lines (+ 2 (send self :num-window-lines )))
             (fit (send self :fit))
             (show-lines 
              (if lines lines (if fit (max 3 (1+ (send dw :nlines))) 7)))
             (new-height (* (send dw :line-height) show-lines)))
       (send dw :size (first (send dw :size)) new-height)))

    (defmeth dw :new-message (text &key (pause 0) (show-time 5) (fit t))
      (send self :start-time (/ (get-internal-real-time)
                        internal-time-units-per-second))
      (send self :flush-window)
      (send self :paste-string (format nil text))
      (send self :new-size)
      (send self :redraw)
      (send self :front-window)
      (send self :top-most t)
      (pause pause)
      (when show-time (send self :reset-time show-time))
      )
    (when click (send dw :idle-on t))

    
    (when show (send dw :show-window :relocate nil))
    (when (or fit shrink-wrap) 
          (send dw :fit-window-to-text)
          (apply #'send dw :size (- (send dw :size) '(0 14))))
    dw))

  
(defun one-line-message 
  (text &key (container *desktop-container*)
        (width (min 500 (max 400 (+ 50 (send *desktop-container* :text-width text)))))
        (location (floor (/ (- (screen-size) (list width 96)) 2)))
        (time 2))
"Args: MESSAGE &Key CONTAINER WIDTH TIME LOCATION
Creates one line message in the title bar. The title bar appears in CONTAINER (*DESKTOP-CONTAINER* by default) for  TIME seconds (5 seconds by default). Time not counted when TIME is NIL (user cannot dismiss it)."
  (send container :container-message nil
        :width width :location location 
        :show-time time :title text :lines 0))
       

  
(defun no-button-dialog (text &key (title " ") (width 300) (pause 0) (show-time 5))
  (let* ((tw (min 500 (max 400 (+ 50 (send *desktop-container* :text-width text)))))
         (loc (floor (/ (- (screen-size) (list tw 96)) 2)))
         (win))
  (cond 
    (*desktop-container*
     (setf win (send *desktop-container* :container-message 
                     (format nil "~%~a" text)
                     :in nil :color 'grey1 :pause pause :show-time show-time :location loc
                     :width tw :click nil :title (if title (string-upcase title) " ")
                     :lines 3))
     (send win :top-most t)
     (send (send win :menu) :remove))
    (t 
     (setf win (post-it text :color 'grey1 :time nil :location loc :width tw :click nil
                        :title (if title (string-upcase title) " ")))))
    win))



(defun initial-post-it-help-window 
  (&optional (message (format nil "~2%"))
             (title  "Help Message       (Click to Remove)")
             &key (width 300)
             (color 'post-it-yellow)
             (pause 0) 
             (show-time nil)
             (fit t))
  (initial-post-it-window 
   message title :width width :color 'post-it-yellow :pause pause :show-time show-time :fit fit))


(defun initial-post-it-window 
  (text &optional 
        (title  " ") 
        &key (width 300) (color 'post-it-yellow) (pause 0) (show-time nil) (fit t))
  (let* ((tw (min 500 (max 400 (+ 50 (send *desktop-container* :text-width text)))))
         (loc (floor (/ (- (screen-size) (list tw 96)) 2)))
         (win))
  (cond 
    (*desktop-container*
     (setf win (send *desktop-container* :container-message 
                     (format nil "~%~a" text)
                     :in nil
                     :color color
                     :show-time show-time
                     :pause pause
                     :location loc
                     :width tw
                     :title (if title (string-upcase title) " ")
                     :fit fit
                     :lines 3))
     (send win :top-most t)
     (send win :no-move nil)
     (send (send win :menu) :remove)
     )
    (t
     (setf win (post-it text :color 'grey1 :time nil :location loc :width tw :click nil
                        :title (if title (string-upcase title) " ")))))
    win))


(setf *post-it-help* nil) 
(setf *post-it* *post-it-window*)



(defun post-it (text &key (title " ") (color 'post-it-yellow used?)
                     (show-time nil) (pause 0) (fit t))
"Args: message &optional title &key (pause 0) (show-time nil) (fit t)
Shows a yellow post-it MESSAGE for PAUSE plus SHOW-TIME seconds. After PAUSE seconds the dialog can be dismissed by clicking on it. Will dismiss itself after PAUSE + SHOW-TIME seconds, unless SHOW-TIME is nil. Fits to text unless FIT is NIL."
  (if (and *post-it* (send *vista* :reuse-help-windows) (not used?))
      (send *post-it* :new-message (strcat "~%" text) 
            :pause pause :show-time show-time :fit fit)
      (setf *post-it* 
            (initial-post-it-window text "Post It     (click to close)" :color color
                                    :pause pause :show-time show-time :fit fit)))
  (send *post-it* :title title)
  (send *post-it* :redraw)
  (setf *post-it-window* *post-it*)
  *post-it*)



(defun post-it-help (text &key (title "ViSta Help")(show-time 8) (pause 0))
"Args: message &optional title &key (pause 0) (show-time 8)
Shows a yellow post-it MESSAGE for PAUSE plus SHOW-TIME seconds. After PAUSE seconds the dialog can be dismissed by clicking on it. Will dismiss itself after PAUSE + SHOW-TIME seconds, unless SHOW-TIME is nil."
  (if *post-it-help* (send *post-it-help* :new-message (strcat "~%" text)
                           :pause pause :show-time show-time)
      (setf *post-it-help* 
            (initial-post-it-help-window 
             text "HELP     (click to close)" :color 'post-it-yellow
             :pause pause :show-time show-time)))

  (send *post-it-help* :title title)
  (send *post-it-help* :redraw)
  (setf *post-it-help-window* *post-it-help*)
  *post-it-help*)

        
(defun one-liner (&rest args) 
"Args: MESSAGE &Key CONTAINER WIDTH TIME LOCATION
Creates a one line message using the title bar only. The title bar appers in CONTAINER (*DESKTOP-CONTAINER* by default) for  TIME seconds (5 seconds by default). Time not counted when TIME is NIL (user cannot dismiss it)."
  (apply #'one-line-message args))

(defun message (&rest args) 
  "Alias of help-window"
  (apply #'help-window args))

(defun text (&rest args) 
  "Alias of help-window"
  (apply #'help-window args))

;the help function is in lspsrc/help.lsp
;the help-window function is the basic function in vista's system for presenting
;help in a help window

(defun help-window 
  (&optional text &key
             (location nil) (size (list 475 300)) (center nil)
             (in nil) (show t) (pop-out t) (top-most nil) (fit t) 
             (print-help-only *print-help-mode*)
             (flush t) (menu t) (color 'post-it-yellow) (title "ViSta Help"))
"Args: text &key (location (list (floor (/ (- (first (effective-screen-size)) 475) 2)) 60)) (size (list 475 300)) (title \"Help Window\") (show t) (pop-out t) (top-most nil) (fit t) (flush t) (menu t) (center nil) (color 'post-it-yellow) ) 
Creates a popped-out help display window and sets all system information to recognize it as a help window."
  (let* ((w *help-window*)
         (new-window)
         (new-location)
         (loc)
         (tloc)
         )
    ; (when w (unless (send *vista* :reuse-help-windows)(setf w nil)))
    (when print-help-only
          (send *vista* :help-window-object nil)
          (setf show nil)
          )
;(one-button-dialog (format nil  "one ~a" show))
    (cond 
      (w (when flush (send w :flush-window)))
      (t (setf w  (initial-help-window))
         (setf loc (send w :location))
         (setf tloc (send w :location))
         (send w :true-location tloc)
         (setf *help-window* w)))

;(one-button-dialog (format nil  "two ~a" show))
;(print (list w show text fit size))
    (send w :back-color color)
    (apply #'send w :size size)
    (send w :title title)
    (send w :scroll 0 0)
    (send *vista* :set-help-variables w t)
    (when text (send w :paste-string text)
          (when fit (send w :fit-window-to-text)))
    (setf size (send w :size))

;(one-button-dialog (format nil "three ~a" show))
    (setf new-location
          (cond 
            ((not (send w :true-location))
             (send w :true-location
                   (list (floor (/ (- (first (effective-screen-size)) 475) 2)) 
                         (+ (second (send *desktop-container* :location)) 50))))
            ((not (= (send w :location) (send w :true-location)))
             (send w :true-location))
            (center 
             (+ (floor (/ (- (screen-size) size) 2)) '(0 80)))
            (location 
             location)
            (t 
             (list (floor (/ (- (first (effective-screen-size)) 475) 2)) 
                   (+ (second (send *desktop-container* :location)) 50)))))
    (send w :true-location new-location)
    (when show
          (send w :bottom-most t)
          (send w :show-window)
          (send w :top-most t)
          (unless top-most (send w :top-most nil))
          (when pop-out (send w :pop-out t))
         )

    (defmeth w :close ()
      (send self :idle-on nil)
      (send self :true-location (send self :location))
      (send self :location 2000 2000))

    (defmeth w :hide-window ()
      (send self :idle-on nil)
      (send self :true-location (send self :location))
      (send self :location 2000 2000))

    (defmeth w :show-window (&key (relocate nil))
      (if relocate
          (apply #'send self :location (send self :true-location))
          (call-next-method :relocate relocate)))

    (send w :true-location (send w :location))
;(one-button-dialog (format nil "four ~a" show))
    (when show (send w :pop-out t) (send w :front-window))
    w))


(defun plot-help-window (title &key (flush t))
"Creates and uses *help-window* - a popped-out help window."
(when *verbose* (PRINT "PLOT-HELP-WINDOW"))
  (help-window nil :title title :flush flush))


(defun vista-warning-window (string)
"Arg: STRING
Presents vista warning window displaying STRING."
  (vista-message string :title "ViSta Warning"))

(defun vista-error-window (string)
"Arg: STRING
Presents vista error window displaying STRING."
  (vista-message string :title "ViSta Error"))

(defun vista-warning-message (&rest args)
  (apply #'vista-message args))


#|

EXPERIMENTAL CODE

(defun make-post-it 
  (message &key in relocate size (location nil) (width 350) 
           (title " ") (show t) (center t) (click t) (lines nil) 
           pop-out top-most free local-menus menu 
           (show-time nil) (color 'white) (shrink-wrap nil) (pause 0) )
  (let* ((tw 
          (cond 
            ((or (not lines) (not title))
             width)
            ((= lines 0)
             (floor (* .9 (send self :text-width title))))
            (t
             width)))
  (send timed-display-window-proto :new
        (message :in in :relocate nil
                 :size (list tw 0) :location location :width width
                 :title title :color color :show nil
                 :free nil :local-menus t :menu t 
                 :center center :click click
                 :show-time show-time :shrink-wrap shrink-wrap 
                 :pause pause :lines lines)
        ))




(defproto timed-display-window-proto '(real-location start-time show-time) () display-window-proto2)


(defmeth timed-display-window-proto :real-location (&optional (list nil set))
  (if set (setf (slot-value 'real-location) list))
  (slot-value 'real-location))
    
(defmeth timed-display-window-proto :start-time (&optional (real nil set))
      (if set (setf (slot-value 'start-time) real))
      (slot-value 'start-time))

(defmeth timed-display-window-proto :is-new 
  (message &key in relocate size location width title color show
        free local-menus menu center click
        show-time color shrink-wrap pause lines)
  (let* ((lines) (show-lines) (new-height) 
         (pop-out (not in))
         (top-most pop-out))
    (send self :start-time (/ (get-internal-real-time)
                        internal-time-units-per-second))
    (unless lines (setf lines 6))
    
    (cond 
      ((= lines 0) 
       (send self :has-v-scroll nil)
       (send self :size tw -10)
       (apply #'send self :location 
              (floor (/ (- *real-screen-size* 
                           (list (first (send self :size)) 0)) 2))))
      (t
       (send self  :back-color color)
       (send self :redraw)
       (send self :paste-string message)
       (setf show-lines (if lines lines
                            (if shrink-wrap 
                                (max 3 (1+ (send self :nlines))) 
                                7)))
       (setf new-height (* (send self :line-height) show-lines))
       (send self :size (first (send self :size)) new-height)
       (when center
             (apply #'send self :location 
                    (+ '(0 10) (floor (/ (- *real-screen-size* 
                                            (list (first (send self :size)) new-height))
                                            2)))))
       (send self :redraw)
       (when click (send self :idle-on t))
       (when show (send self :show-window :relocate nil))
       (send self :no-move t)
       ))
    self))


    (defmeth timed-display-window-proto :close ()
      (send dw :idle-on nil)
      (send dw :real-location (send dw :location))
      (send dw :location 2000 2000)
      (send dw :remove)
      (setf *please-wait* nil))

    (defmeth timed-display-window-proto :do-click (x y m1 m2)
      (send dw :close))

    (defmeth timed-display-window-proto :do-idle ()
      (let ((start-time (send self :start-time))
            (current-time (/ (get-internal-real-time)
                             internal-time-units-per-second)))
        (when (and show-time
                   (> (- current-time start-time) show-time)) 
              (send dw :remove))))

    (defmeth timed-display-window-proto :reset-time (time)
      (setf show-time time)
      (send self :idle-on t))

    (defmeth timed-display-window-proto :click (logical)
      (send dw :idle-on logical))


    (defmeth timed-display-window-proto :new-message (text &key (pause 0))
      (send self :start-time (/ (get-internal-real-time)
                        internal-time-units-per-second))
      (send self :flush-window)
      (send self :paste-string (format nil text))
      (send self :redraw)
      ; (send self :front-window)
      (send self :top-most t)
      ;(send (send self :container) :show-window)
      (pause pause)
      (when show-time (send self :reset-time show-time))
      )

    
                            
|#
